home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / static-fn.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  4.9 KB  |  154 lines

  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: static-fn.lisp,v 1.15 91/07/14 03:46:41 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: static-fn.lisp,v 1.15 91/07/14 03:46:41 wlott Exp $
  15. ;;;
  16. ;;; This file contains the VOPs and macro magic necessary to call static
  17. ;;; functions.
  18. ;;;
  19. ;;; Written by William Lott.
  20. ;;;
  21. (in-package "MIPS")
  22.  
  23.  
  24.  
  25. (define-vop (static-function-template)
  26.   (:save-p t)
  27.   (:policy :safe)
  28.   (:variant-vars symbol)
  29.   (:vop-var vop)
  30.   (:temporary (:scs (non-descriptor-reg)) temp)
  31.   (:temporary (:scs (descriptor-reg)) move-temp)
  32.   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
  33.   (:temporary (:sc descriptor-reg :offset cname-offset) cname)
  34.   (:temporary (:scs (interior-reg) :type interior) lip)
  35.   (:temporary (:sc any-reg :offset nargs-offset) nargs)
  36.   (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
  37.   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
  38.  
  39.  
  40. (eval-when (compile load eval)
  41.  
  42.  
  43. (defun static-function-template-name (num-args num-results)
  44.   (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
  45.           num-args num-results)))
  46.  
  47.  
  48. (defun moves (dst src)
  49.   (collect ((moves))
  50.     (do ((dst dst (cdr dst))
  51.      (src src (cdr src)))
  52.     ((or (null dst) (null src)))
  53.       (moves `(move ,(car dst) ,(car src))))
  54.     (moves)))
  55.  
  56. (defun static-function-template-vop (num-args num-results)
  57.   (assert (and (<= num-args register-arg-count)
  58.            (<= num-results register-arg-count))
  59.       (num-args num-results)
  60.       "Either too many args (~D) or too many results (~D).  Max = ~D"
  61.       num-args num-results register-arg-count)
  62.   (let ((num-temps (max num-args num-results)))
  63.     (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
  64.       (dotimes (i num-results)
  65.     (let ((result-name (intern (format nil "RESULT-~D" i))))
  66.       (result-names result-name)
  67.       (results `(,result-name :scs (any-reg descriptor-reg)))))
  68.       (dotimes (i num-temps)
  69.     (let ((temp-name (intern (format nil "TEMP-~D" i))))
  70.       (temp-names temp-name)
  71.       (temps `(:temporary (:sc descriptor-reg
  72.                    :offset ,(nth i register-arg-offsets)
  73.                    ,@(when (< i num-args)
  74.                    `(:from (:argument ,i)))
  75.                    ,@(when (< i num-results)
  76.                    `(:to (:result ,i)
  77.                      :target ,(nth i (result-names)))))
  78.                   ,temp-name))))
  79.       (dotimes (i num-args)
  80.     (let ((arg-name (intern (format nil "ARG-~D" i))))
  81.       (arg-names arg-name)
  82.       (args `(,arg-name
  83.           :scs (any-reg descriptor-reg)
  84.           :target ,(nth i (temp-names))))))
  85.       `(define-vop (,(static-function-template-name num-args num-results)
  86.             static-function-template)
  87.      (:args ,@(args))
  88.      ,@(temps)
  89.      (:results ,@(results))
  90.      (:generator ,(+ 50 num-args num-results)
  91.        (let ((lra-label (gen-label))
  92.          (cur-nfp (current-nfp-tn vop)))
  93.          ,@(moves (temp-names) (arg-names))
  94.          (inst li nargs (fixnum ,num-args))
  95.          (load-symbol cname symbol)
  96.          (inst lw lip cname
  97.            (- (ash vm:symbol-raw-function-addr-slot vm:word-shift)
  98.               vm:other-pointer-type))
  99.          (when cur-nfp
  100.            (store-stack-tn nfp-save cur-nfp))
  101.          (inst move old-fp cfp-tn)
  102.          (inst compute-lra-from-code lra code-tn lra-label temp)
  103.          (inst j lip)
  104.          (inst move cfp-tn csp-tn)
  105.          (emit-return-pc lra-label)
  106.          (note-this-location vop :unknown-return)
  107.          ,(collect ((bindings) (links))
  108.         (do ((temp (temp-names) (cdr temp))
  109.              (name 'values (gensym))
  110.              (prev nil name)
  111.              (i 0 (1+ i)))
  112.             ((= i num-results))
  113.           (bindings `(,name
  114.                   (make-tn-ref ,(car temp) nil)))
  115.           (when prev
  116.             (links `(setf (tn-ref-across ,prev) ,name))))
  117.         `(let ,(bindings)
  118.            ,@(links)
  119.            (default-unknown-values
  120.                ,(if (zerop num-results) nil 'values)
  121.                ,num-results move-temp temp lra-label)))
  122.          (when cur-nfp
  123.            (load-stack-tn cur-nfp nfp-save))
  124.          ,@(moves (result-names) (temp-names))))))))
  125.  
  126.  
  127. ) ; eval-when (compile load eval)
  128.  
  129.  
  130. (expand
  131.  (collect ((templates (list 'progn)))
  132.    (dotimes (i register-arg-count)
  133.      (templates (static-function-template-vop i 1)))
  134.    (templates)))
  135.  
  136.  
  137. (defmacro define-static-function (name args &key (results '(x)) translate
  138.                        policy cost arg-types result-types)
  139.   `(define-vop (,name
  140.         ,(static-function-template-name (length args)
  141.                         (length results)))
  142.      (:variant ',name)
  143.      (:note ,(format nil "static-function ~@(~S~)" name))
  144.      ,@(when translate
  145.      `((:translate ,translate)))
  146.      ,@(when policy
  147.      `((:policy ,policy)))
  148.      ,@(when cost
  149.      `((:generator-cost ,cost)))
  150.      ,@(when arg-types
  151.      `((:arg-types ,@arg-types)))
  152.      ,@(when result-types
  153.      `((:result-types ,@result-types)))))
  154.